Developer CD Series 1993…ch: Other People's Memory/ADC Developer CD (1993-03) (''Other People's Memory'')_iso/Dev.CD Mar 93.iso/Development Platforms/LISP Related/LISP Goodies/btree/btree.lisp

Text File | 1992-09-02 | 51.2 KB | 1,510 lines | [TEXT/CCL2]

(in-package :btree)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; btree.lisp
;;
;; Copyright © 1992 University of Toronto, Department of Computer Science
;; All Rights Reserved
;;
; author: Mark A. Tapia [e-mail] or [e-mail]
;;
;; Package for manipulating balanced avl trees.
;;
;; Acknowledgements:
;;
;; Revision history:
;;
;; Work to do:
;;   Support tree-merging and concatenation (an entire tree is to be inserted
;;   to the right of an existing tree).
;;
;; Within avl-tree, order-function is a function of two arguments (u v)
;; reflecting a total ordering on the keys.
;; The value returned is one of {*equal*, *before*, *after*}
;;   when (u = v), (order-function u v) = *equal*
;;        (u < v), (order-function u v) = *before*
;;        (u > v), (order-function u v) = *after*
;;
;;  The algorithms are based on the balanced tree algorithms in Knuth
;;  The Art of Computer Programming, Searching and Sorting Volume III
;;  sections 6.2.2 - 6.2.4 with modifications.
;;
;;  The balanced trees are red-black trees augmented with points to
;;  allow fast reporting and updating. The representation is described in
;;  Cheng SW and Janardon R, "Efficient maintenance of the union intervals
;;  on a line, with applications", Proceedings of the First Annual ACM-SIAM
;;  Symposium on Discrete Algorithms, SIAM pp74-83.
;;
;;  The additional fields are marked with an asterisk (*)
;;
;;  Given a btree record for a non-null node v, the following fields are defined
;;  *   min     - either a pointer to the leftmost leaf of the subtree
;;                or nil if v is the leftmost node of the tree rooted at v
;;  *   max     - either a pointer to the rightmost leaf of the subtree
;;                or nil if v is the rightmost node of the tree rooted at v
;;      key     - the key associated with v
;;      val     - the value associated with the key key of v
;;      left    - a pointer to the left children of v
;;      right   - a pointer to the right children of v
;;      balance - the balance factor of the rooted subtree v
;;                *balanced*     - the right and left branches are equal in height
;;                *right-taller* - the right branch is one level taller than the left
;;                *left-taller*  - the left branch is one level taller than the right
;;

(eval-when (eval compile)
  (require 'btree-decl)
  (require 'macros))

(provide 'btree)

(export '(add-node
          delete-node
          find-path
          find-key
          *copy-btree
          direct-find-key
          print-path
          print-tree
          from-btreek
          root-path
          to-btreek
          is-leaf
          max-val
          min-val
          *to-btree
          get-next-node
          operate-on-tree
          find-root) :btree)


(setf *print-circle* t)

(defparameter *debug* nil)

(defun is-debug ()
  *debug*)

;;; macros

(defmacro found-node (new-node path)
  `(push (list *equal* ,new-node) ,path))

(defmacro root-path (root)
  "A path consisting of the root of the tree"
  `(when ,root
     (list (list *equal* ,root))))

(defmacro select (exp &body body)
  (let ((var (gensym)) code condition)
    (dolist (frag body)
      (setf condition (nth 0 frag))
      (push
       (cons
        (if (member condition '(t otherwise))
          t
          (list 'equal var condition))
        (rest frag))
       code))
    (setf code (nreverse code))
    (push 'cond code)
    (setf code (list code))
    (push `((,var ,exp)) code)
    (push 'let code)
    `,code))

(defmacro add-turn (new-node node temp path dir)
  `(progn
     (if (= ,dir *right*)
       (setf (btree-right ,node) ,new-node)
       (setf (btree-left ,node) ,new-node))
     (setf (btrail-dir ,temp) ,dir)
     (found-node ,new-node ,path)))

#|
;; example
(defvar fruit 'apple)
(select fruit
        ('apple 'doctor)
        ('peach 'lover)
        (otherwise nil))
;; prints doctor
|#

;; Macro which performs operations on a btree, starting at the root.
;;
;; When the root is empty:
;;    1. Executes the null-action
;; Otherwise threads through the tree from top to bottom and left to right,
;; applying the following actions:
;;    1. Applies the node-action to the tree
;;    2. Binds the node to the left branch and binds the left positional parameter to the node.
;;       When the left branch is not empty, evaluates the expression
;;       corresponding to the branch action.
;;    2. Binds the node to the right branch and binds the left positional parameter to the node.
;;       When the left branch is not empty, evaluates the expression
;;       corresponding to the branch action.
;;    4. Evaluates and returns the return expression.
;;
(defmacro operate-on-tree ((node tree &optional (left (gensym)) (right (gensym))) &key
                           (return nil)
                           null-action
                           node-action
                           branch-action)
  `(let (,node ,left ,right)
     (declare (ignorable ,left ,right))
     (if (null ,tree)
       ,null-action
       (progn
         ,node-action
         (when (setq ,node (btree-left ,tree)
                     ,left ,node)
           ,branch-action)
         (when (setq ,node (btree-right ,tree)
                     ,right ,node)
           ,branch-action)
         ,return))))

#|
;; Basic example: visits every node and does nothing, returning the tree
(defun walk-tree (tree)
  (operate-on-tree (node tree)
                   :return tree))

;; Prints all nodes in a path starting from the root,
;; composed of alternating left and right turns,
(defun print-turn (tree &optional (dir *left*))
  (operate-on-tree (node tree left right)
                   :node-action (print (btree-key tree))
                   :branch-action (if (equal dir *left*)
                                    (when (eq node left) (print-turn node *right*))
                                    (when (eq node right) (print-turn node *left*)))))

;; Returns a sorted list of the keys of a btree in descending order
(defun print-key (tree &optional values)
  (let (print-node)
    (operate-on-tree (node tree left right)
                     :node-action (setq print-node t)
                     :branch-action (if (eq node left)
                                      (setq values (print-key node values))
                                      (progn (push (btree-key tree) values)
                                             (setq values (print-key node values))
                                             (setq print-node nil)))
                     :return (progn
                               (when
                                 print-node (push (btree-key tree) values))
                               values))))
|#

;; basic copy function

(defun *copy-btree (u &optional (descend 0))
  "Create a copy of a btree using the integer descend to control how
to copy the values.
Copy the keys using copy-tree.
Copy the values in one of two ways:
   If descend > 0, decrement descend and
     copy the btrees corresponding to the node values.
   Otherwise use copy-tree to copy the values"
  (let* ((val (if (> descend 0)
                (*copy-btree (btree-val u) (1- descend))
                (copy-tree (btree-val u))))
         new-node
         min
         max)
    (operate-on-tree (node u left right)
                     :node-action (setq new-node (make-btree :key (copy-tree (btree-key u))
                                                             :val val
                                                             :balance (btree-balance u)))
                     :branch-action (*copy-btree node descend)
                     :return (progn
                               (setq min (or (btree-min left) left)
                                     max (or (btree-max right) right))
                               (setf (btree-min new-node) min
                                     (btree-max new-node) max
                                     (btree-right new-node) right
                                     (btree-left new-node) left)
                               new-node))))

;; basic comparison functions
(defun compare (m n)
  ;; for integers m and n, behaves like a fortran computed if
  (cond ((= m n) *equal*)
        ((< m n) *before*)
        (t *after*)))

(defun is-less (a b the-pred)
  (= (funcall the-pred a b) *before*))

;; basic tree functions
(defun check-tree (tree min max)
  "determines whether the tree is height balanced and all nodes in the tree
are between min and max"
  (and (all-height-balanced tree)
       (check-tree1 tree min max)))

(defun check-tree1 (tree min max)
  "determines whether the nodes in the tree range between the min and max
values of the parent"
  (let (node)
    (if (null tree)
      t
      (and
       (if (or (> (btree-key tree) max)
               (< (btree-key tree) min))
         (progn
           (print-db max min (btree-key tree)
                     (> (btree-key tree) max)
                     (< (btree-key tree) min))
           (print-tree tree)
           nil)
         t)
       (progn
         (setq node (btree-left tree))
         (and (or (null node)
                  (<= (min-val node) (btree-key tree)))
              (check-tree1 node (min-val node) (max-val node))))
       (progn (setq node (btree-right tree))
              (and (or (null node)
                       (>= (max-val node) (btree-key tree)))
                   (check-tree1 node (min-val node) (max-val node))))))))

;; btree height functions

(defun metric-btree (btree)
  "Print a count of the number of nodes in a tree, the maximum height and
the deviation from the ideal"
  (let ((nodes (count-nodes btree))
        (height (height-btree btree)))
    (format t "~&nodes=~d height=~d ideal/actual = ~d%~%"
            nodes height (round (* 100 (log nodes 2))  height)
            )))

(defun height-btree (btree &optional (n 0))
  (if (null btree) n
      (max (height-btree (btree-left btree) (1+ n))
           (height-btree (btree-right btree) (1+ n)))))

(defun count-nodes (btree)
  (if (null btree) 0
      (+ (1+ (count-nodes (btree-left btree)))
         (count-nodes (btree-right btree)))))

;; link routines from Knuth
(defun link (dir node)
  ;;  (link *right* node) = (btree-right node)
  ;;  (link *left* node)  = (btree-left node)
  (if (equal dir *right*)
    (btree-right node)
    (btree-left node)))

(defun set-link (dir node value)
  ;;  (set-link *right* node value) = (setf (btree-right node) value)
  ;;  (set-link *left* node value)  = (setf (btree-left node) value)
  (when node
    (if (equal dir *right*)
      (setf (btree-right node) value)
      (setf (btree-left node) value))))

;;; Printing
;;       trees
(defun balance-string (node)
  (select (btree-balance node)
    (*right-taller* "R")
    (*left-taller* "L")
    (*balanced* " ")
    (otherwise "?")))

(defun direction-string (dir)
  (select dir
    (*right* "R")
    (*left* "L")
    (*equal* " ")
    (otherwise ".")))

(defun tree-direction-string (dir)
  (select dir
    (*right* "L:")
    (*left* "R:")
    (otherwise "=:")))

(defun print-node (u level dir &key title)
  (format t "~&~@?~a ~s ~a [~d ~d] ~a~%"
          (format nil "~~~dt"  level)
          (balance-string u)
          (btree-key u)
          (direction-string dir)
          (btree-key (btree-min u))
          (btree-key (btree-max u))
          (if title
            title
            " ")))

(defun print-tree (u &key title)
  (when title
    (format t "~&~a~%" title))
  (print-tree1 u 1 *equal*))

(defun print-tree1 (u level dir)
  (when u
    (print-node u level dir)
    (print-tree1 (btree-left u) (1+ level) *left*)
    (print-tree1 (btree-right u) (1+ level) *right*)))

(defun print-root (path)
  (print-tree (find-root path)))

;;      Paths
(defun print-path (path &key title)
  (let (key direction)
    (format t "~&~a Path length ~d ~%"
            (if title title " ")
            (length path))
    (dolist (u path)
      (setf direction (btrail-dir u)
            key (btrail-node u))
      (if direction
        (format t "~&~s ~a [~s ~s] ~d~%"
                (btree-key key)
                (direction-string direction)
                (btree-key (btree-min key))
                (btree-key (btree-max key))
                (balance-string key))
        (format t "~&~s~%" key)))))

;; basic path routines
(defun is-root (path)
  (or (null path) (null (rest path))))

;; converting to/from trees and lists
;;  (to-btree (from-btree tree) order-function) = tree
;;  (from-btree (to-btree list order-function)) = list

(defun to-btreek (key-list order-function &key debug)
  "Converts the list of keys in key-list to a btree with
key =  value.  Uses the order-function
that returns *before* *equal* *after* and optionally prints the
tree as it is being assembled"
  (let (root path a-key title)
    (when key-list
      (setf root (make-btree
                  :key (setq a-key (pop key-list))
                  :val a-key)
            path (root-path root))
      (loop for a-key in key-list
            do (setf path (add-node a-key a-key (root-path root) order-function))
            (setq root (find-root path))
            (when debug
              (setf title (format nil "**add ~s" a-key))
              (print-path path :title title)
              (print-tree root :title title)))
      root)))

(defun to-btree (key-list order-function &key debug)
  "Converts the list of (key value) in key-list to a btree.
Uses the order-function that returns *before* *equal* *after*
and optionally prints the
tree as it is being assembled"
  (let (root path key-part title)
    (when key-list
      (setf key-part (pop key-list)
            root (make-btree
                  :key (first key-part)
                  :val (second key-part)
                  :balance *balanced*)
            path (root-path root))
      (dolist (key-part key-list)
        (setq path
              (add-node (first key-part)
                        (second key-part)
                        path
                        order-function))
        (when debug
          (setf title (format nil "**add ~s" (first key-part)))
          (print-path path :title title)
          (print-tree root :title title)))
      root)))

(defun from-btree (tree)
  "Convert a btree to a list of the form ((key val) ... (keyn valn)) sorted by key"
  (nreverse (from-btree1 tree nil)))

(defun from-btree1 (tree nodes)
  ;; covert to a list sorted by key in descending order
  (let (print-node)
    (operate-on-tree (node tree left right)
                     :node-action (setq print-node t)
                     :branch-action (if (eq node left)
                                      (setq nodes (from-btree1 node nodes))
                                      (progn
                                        (push  (list (btree-key tree)
                                                     (btree-val tree))
                                               nodes)
                                        (setq print-node nil)
                                        (setq nodes (from-btree1 node nodes))))
                     :return (progn
                               (when print-node
                                 (push  (list (btree-key tree)
                                              (btree-val tree))
                                        nodes))
                               nodes))))

;; --> basic node routines
(defun check-leaf (node)
  "For a leaf node, fills in the min and max and balance fields."
  (when (and node (is-leaf node))
    (setf (btree-balance node) *balanced*
          (btree-max node) nil
          (btree-min node) nil)))

(defun is-leaf (node)
  "Returns t iff the node is a leaf node"
  (or (null node)
      (and (null (btree-left node))
           (null (btree-right node)))))

(defun replace-node (source replacement)
  "When source and replacement are lists, interchanges the two lists"
  (when (and source (listp source) (listp replacement))
    (setf (first source) (first replacement)
          (rest source) (rest replacement))))

(defun interchange-nodes (node1 node2)
  "Interchanges node1 and node2"
  (let ((temp-node (copy-list node1)))
    (replace-node node1 node2)
    (replace-node node1 temp-node)))

(defun swap-key (node1 node2 &key balance)
  "Swaps the keys associated with btrede nodes node1 and node2 and optionally swaps the balance"
  (unless (and node1 node2)
    (break "bad-swap-nodes"))
  (rotatef (btree-key node1) (btree-key node2))
  (rotatef (btree-val node1) (btree-val node2))
  (when balance
    (rotatef (btree-balance node1) (btree-balance node2))))

(defun copy-info (source destination &key left right max min balance)
  "Copies selected fields from the source to the destination node.
By default replaces the key and values fields in the destination by the source.
When the keyword parameter values are non nil, replaces these fields as well"
  (unless (and source destination)
    (break "bad-copy"))
  (setf (btree-key destination) (btree-key source)
        (btree-val destination) (btree-val source))
  (when left
    (setf (btree-left destination) (btree-left source)))
  (when right
    (setf (btree-right destination) (btree-right source)))
  (when max
    (setf (btree-max destination) (btree-max source)))
  (when min
    (setf (btree-min destination) (btree-min source)))
  (when balance
    (setf (btree-balance destination) (btree-balance source)))
  destination)

;; --> min/max routines

(defun get-max (node)
  "Return the rightmost node in the tree rooted at node"
  (or (btree-max node)
      node))

(defun get-min (node)
  "Return the leftmost node in the tree rooted at node"
  (or (btree-min node)
      node))

(defun max-val (node)
  "Return the key associated with the rightmost node in the tree rooted at node"
  (let ((max-node (get-max node)))
    (btree-key
     max-node)))

(defun min-val (node)
  "Return the key associated with the leftmost node in the tree rooted at node"
  (let ((min-node (get-min node)))
    (btree-key
     min-node)))

(defun put-min-max (min-max default &optional other)
  "Returns the first non-null value in min-max default other"
  (or min-max
      default
      other))

(defun set-min-max (node &optional (descend 0))
  (when node
    (when (> descend 0)
      (set-min-max (btree-val node) (1- descend)))
    (if (is-leaf node)
      (values node node)
      (let ((min (set-min-max (btree-left node) descend)))
        (multiple-value-bind (minr max)
                             (set-min-max (btree-right node) descend)
          (declare (ignore minr))
          (setf (btree-min node) min
                (btree-max node) max)
          (values min max))))))

(defun supply-min/max (parent child)
  "If child is the left/right node of the parent, returns the node;
otherwise returns the parent"
  (if child
    child
    parent))

(defun fix-max-min (node)
  "Ensures that the node has the proper min and max links and that
the left and right children are fixed if they are leaves."
  (let (left right)
    (when node
      (setq left (btree-left node)
            right (btree-right node))
      (check-leaf left)
      (check-leaf right)
      (setf (btree-min node) (put-min-max (get-min left) left)
            (btree-max node) (put-min-max (get-max right) right))
      (when (is-debug)
        (print-db (btree-key node) (min-val node) (max-val node))))))

(defun q-adjust-max (path)
  "Adjusts a path of the form (dir node) ... (dir node)
setting the max  links appropriately  for each node for all right turns"
  (let (new-max)
    (when path
      (setq new-max (get-max (btrail-node (first path)))))
    (loop for temp in (rest path)
          with dir and node
          do (setq dir (btrail-dir temp)
                   node (btrail-node temp))
          until (equal dir *left*)
          do (setf (btree-max node)
                   (unless (eq new-max node)
                     new-max)))))

(defun q-adjust-max-min (path)
  "Adjusts a path of the form (dir node) ... (dir node)
setting the max (and min) links appropriately for each node for all right (and left) turns"
  (q-adjust-max path)
  (q-adjust-min path))

(defun q-adjust-min (path)
  "Adjusts a path of the form (dir node) ... (dir node)
setting the min links appropriately for all left turns"
  (let (new-min)
    (when path
      (setq new-min (get-min (btrail-node (first path)))))
    (loop for temp in (rest path)
          with dir and node
          do (setq dir (btrail-dir temp)
                   node (btrail-node temp))
          until (equal dir *right*)
          do (setf (btree-min node)
                   (unless (eq new-min node)
                     new-min)))))

(defun adjust-max (new-max path)
  "Adjusts a path of the form (dir node) ... (dir node)
setting the max links appropriately for each node for all right turns"
  (loop for temp in path
        with dir and node
        do (setq dir (btrail-dir temp)
                 node (btrail-node temp))
        until (equal dir *left*)
        do (setf (btree-max node)
                 (unless (eq new-max node)
                   new-max))))

(defun adjust-min (new-min path)
  (let (node)
    (dolist (temp path)
      (setf node (btrail-node temp))
      (if (eq node new-min)
        (setf (btree-min node) nil)
        (select (btrail-dir temp)
          (*equal* (setf (btree-min node) nil))
          (*right* (return t))
          (*left*
           (setf (btree-min node)
                 (if (eq new-min node)
                   nil
                   new-min))))))))

;; --> turn routines

(defun extreme-turn (path dir)
  "continue turning in the direction dir from the last node in path
until no more dir turns are possible"
  (let (temp node old-path)
    (loop
      (setf temp (first path)
            node (btrail-node temp))
      (when (or (is-leaf node) (eq path old-path))
        (return path))
      (setf old-path path
            path (turn-immediate path dir)))))

(defun extreme-left (path)
  "continue turning left from the last node in path
until no more left turns are possible"
  (extreme-turn path *left*))

(defun extreme-right (path)
  "continue turning right from the last node in path
until no more right turns are possible"
  (extreme-turn path *right*))

(defun turn (path dir)
  "Turn in the direction dir from the last node in the path"
  (let (temp
        old-dir
        new-node
        node
        (old-path path))
    (loop
      (unless path
        (return old-path))
      (setf temp (first path)
            old-dir (btrail-dir temp)
            node (btrail-node temp)
            new-node (select old-dir
                       (*equal* (turn1 node dir)) ; haven't already turned left or right
                       (*before*
                        (when (= dir *right*) ; haven't already turned right
                          (turn1 node dir)))))
      (when new-node
        (setf (btrail-dir temp) dir)
        (found-node new-node path)
        (return path))
      (pop path))))

(defun turn-immediate (path dir)
  "Make a dir (left/right) turn from the last node in path"
  (let* ((temp (first path))
         (node (btrail-node temp))
         new-node)
    ; when the node is not a leaf and it is possible to turn in the dir direction
    (unless (or (is-leaf node)
                (null (setf new-node (turn1 node dir))))
      (setf (btrail-dir temp) dir)
      (found-node new-node path)
      path)))

(defun turn1 (node dir)
  (when node
    (select dir
      (*left* (btree-left node))
      (*right*  (btree-right node))
      (otherwise node))))

(defun retract-path (key path order-function)
  "Backup through the path branch by branch
until either the path is empty or the node with the key lies in the rooted subtree"
  (let (temp new-key dir new-node)
    (when (and path (null (btrail-dir (first path))))
      (pop path))
    (loop
      (unless path
        (return path))
      (setf temp (first path)
            dir (btrail-dir temp)
            new-node (btrail-node temp)
            new-key (btree-key new-node))
      (select (funcall order-function key new-key)
        (*equal*
         (return path))
        (*after*
         (unless (= (funcall order-function key (max-val new-node)) *after*)
           (unless (= dir *right*)
             (return (setf path (turn path *right*))))))
        (*before*
         (if (= dir *equal*)
           (return
            (if (= (funcall order-function key (min-val new-node)) *before*)
              (setf path (turn path *left*)))))))
      (pop path))))

(defun retract-to-right (path)
  "Retract the path to the node associated with nearest rooted subtree
whose orig-dir (left/right) branch has not yet been explored"
  (let (temp
        node
        dir
        orig-dir)
    (loop
      do (pop path)
      while path
      do (setf temp (first path)
               node (btrail-node temp)
               dir (btrail-dir temp))
      unless orig-dir do (setf orig-dir dir)
      while (and (not (is-leaf node))
                 (not (= dir orig-dir))
                 (btree-right node)))
    path))

;; --> find routines



(defun find-key (key root order-function)
  "Given the key, the root of a btree and the order-function for key comparison:
return the value of the node associated with the key
or nil when it is not found"
  (let ((node root)
        (dir *equal*))
    (loop
      (unless node
        (return nil))
      (select (funcall order-function key (btree-key node))
        (*equal*
         (return (btree-val node)))
        (*before*
         (if (or (is-leaf node)
                 (null (setf node (btree-left node)))
                 (and (not (= dir *left*))
                      (= (funcall order-function key
                                  (min-val node))
                         *before*)))
           (return nil)
           (setf dir *left*)))
        (*after*
         (if (or (is-leaf node)
                 (null (setf node (btree-right node)))
                 (and (not (= dir *right*))
                      (= (funcall order-function key
                                  (max-val node))
                         *after*)))
           (return nil)
           (setf dir *right*)))))))

(defun fast-find (root keys order-function)
  "Given a set of keys, a binary tree root and an order-function.
Sort the keys using the order function. Return t if all
of the keys are in the tree, otherwise return nil."
  (let ((path (root-path root)))
    (flet ((sort-pred (u v)
             (= (funcall order-function u v) *before*)))
      (setf keys (sort keys #'sort-pred))
      (loop for a-key in keys
            do (setf path (find-path a-key path :order-function order-function))
            when (or (null path)
                     (null (btrail-dir (first path)))) do (return nil)
            finally (return t)))))

(defun delete-extreme-left (path parent-node first-right)
  "Delete the parent node.
First-right = (btree-right parent-node).
and path is a right turn from the path to the parent node.
Copy the keys and val of extreme left node of first-right
into the parent node and remove the extreme-left node, modifying the tree"
  (declare (ignore first-right))
  (loop with old-path = path and node and prev-node and right-node
        do (setq path (turn-immediate path *left*))
        until (null path)
        do (setq old-path path)
        finally (progn
                  (setq path old-path)
                  (setq node (btrail-node (first path))
                        prev-node (btrail-node (second path)))
                  (copy-info node parent-node)
                  (setq right-node (btree-right node))
                  (if (is-leaf node)
                    (progn
                      (setf (btree-left prev-node) nil
                            (btree-min prev-node) nil)
                      (pop path))
                    (progn
                      (setq path (turn-immediate path *right*))
                      (copy-info right-node node :left t :right t
                                 :max t :min t)
                      (pop path)))))
  path)

(defun delete-right-node (path parent-node first-right)
  "Delete the parent node where first-right = (btree-right parent-node)
and (btree-left first-right) = nil.
Path is a right turn from the path to the parent node.
Copy the keys and val of first-right
into the parent node and remove the first-right node, modifying the tree"
  (let ((right (btree-right first-right)))
    (copy-info first-right parent-node :right t :max t)
    (if right
      (progn
        (copy-info right first-right :right t :max t :left t :min t)
        (setf (btrail-dir (first path)) *right*))
      (pop path))
    path))

(defun delete-first-greater (path)
  "Delete the first node which is greater than the last node on the path"
  (let (first-right
        (node (btrail-node (first path)))
        parent-node)
    (setq parent-node node
          path (turn-immediate path *right*)
          first-right (btree-right parent-node)
          node first-right)
    (if (null (btree-left first-right))
      (delete-right-node path parent-node first-right)
      (delete-extreme-left path parent-node first-right))))

(defun find-path (key path &key (order-function #'compare) (descend nil))
  "Find the key starting with the path path."
  (let (temp dir node alt-path new-key)
    (when (and path
               (setf temp (first path))
               (null (setf dir (btrail-dir temp))))
      (setf dir (btrail-prev temp))
      (pop path))
    (loop
      (unless path
        (push (list nil key) path)
        (return path))
      (setf temp (first path)
            node (btrail-node temp)
            dir (btrail-dir temp)
            new-key (btree-key node))
      (select (funcall order-function key new-key)
        (*equal*
         (return path))
        (*before*
         (cond ((or (is-leaf node)
                    (and (not descend)
                         (equal dir *right*)
                         (equal (funcall order-function key (min-val node))
                                *before*)))
                (return (push (list nil key *left*) path)))
               ((setf node (btree-left node))
                (setf (btrail-dir temp) *left*)
                (push (list *equal* node) path))
               (t (return (push (list nil key) path)))))
        (*after*
         (cond  ((or (equal dir *right*)
                     (is-leaf node))
                 (if (setf alt-path (retract-path key path order-function))
                   (setf path alt-path
                         temp (first path)
                         node (btrail-node temp)
                         dir (btrail-dir temp))
                   (return (push (list nil key *right*) path))))
                ((setf node (btree-right node))
                 (setf (btrail-dir temp) *right*)
                 (push (list *equal* node) path))
                (t (return (push (list nil key *right*) path)))))))))

(defun quick-path (key root &key (order-function #'compare))
  "Uses the min and max links to find a path (if it exists) to the node with key,
starting with the path at the root"
  (let (node new-key)
    (setf node root)
    (loop
      (setf new-key (btree-key node))
      (select (funcall order-function key new-key)
        (*equal*
         (return node))
        (*before*
         (cond ((is-leaf node)
                (return nil))
               ((setf node (btree-left node)) t)
               (t (return node))))
        (*after*
         (cond  ((is-leaf node)
                 (return nil))
                ((setf node (btree-right node))
                 t)
                (t (return nil))))))))

(defun find-root (path)
  "Given a path, finds the root node of the path"
  (when path
    (btrail-node (first (last path)))))

(defun root-find (tree keys order-function)
  "Determines whether all keys are in the rooted tree, using quick path"
  (let* (node)
    (loop for a-key in keys
          do (setf node (quick-path a-key tree :order-function order-function))
          when (null node) do (return  nil)
          finally (return t))))

(defun slow-find (root keys the-pred)
  (let* ((root-path (root-path root))
         path (mine (first root-path)))
    (loop for a-key in keys
          do (setf (btrail-dir mine) *equal*
                   path (find-path a-key root-path :order-function the-pred))
          when (or (null path)
                   (equal (btrail-node (first path))
                          a-key))
          do (return nil)
          finally (return t))))

(defun get-next-node (start-path)
  "Gets the next node not already visited along the start-path.
The following prints every node of the tree in ascending order
(loop with path = (root-path tree)
      do (setq path (get-next-node path))
      while path
      do (print (btree-key (btrail-node (first path)))))"
  (when start-path
    (loop with path = start-path and node and new-path and dir and node-path = nil
          while path
          do (setq node (first path)
                   dir (btrail-dir node)
                   node (btrail-node node))
          do (if (is-leaf node)
               (if (equal dir *right*)
                 (pop path)
                 (progn
                   (setf (btrail-dir (first path)) *right*)
                   (setq node-path path
                         path nil)))
               (select dir
                 (*done* (setq new-path (turn-immediate path *right*))
                         (if new-path
                           (setq path new-path)
                           (pop path)))
                 (*right* (pop path))
                 (*left* (setf (btrail-dir (first path)) *done*)
                         (setq node-path path
                               path nil))
                 (t (setq new-path (turn-immediate path *left*))
                    (if new-path
                      (setq path new-path)
                      (setf (btrail-dir (first path)) *left*)))))
          finally (return node-path))))

(defun from-btree-to-list (tree &key (get-val #'(lambda (key val) (list key val))))
  "Traverses the balanced binary tree in key order,
collecting (funcall get-val  key value)"
  (loop with path = (root-path tree) and node
        do (setq path (get-next-node path))
        while path
        do (setq node (btrail-node (first path)))
        collect (funcall get-val (btree-key node) (btree-val node))))

;; -> path adjustment
(defun adjust-path (path w-node y-node)
  "adjusts the path, so that if w-node is the first node along the path,
w-node is the appropriate turn from its parent y-node"
  (when (eq (btrail-node (first path)) w-node)
    (setf (btrail-dir (first path))
          (cond((eq (btree-left w-node) y-node) *left*)
               ((eq (btree-right w-node) y-node) *right*)
               (t (break)))))
  path)

(defun fix-path (path)
  "Fixes the path, adjusting the min and max values for left/right turns"
  (fix-left-path path)
  (fix-right-path path))

(defun fix-left-path (path)
  (when path
    (loop
      while (rest path)
      with min = (btrail-node (first path)) and x-trail = (first path) and node
      do (pop path)
      do (setq x-trail (first path))
      while (equal (btrail-dir x-trail) *left*)
      do (setf (btree-min (btrail-node x-trail)) (get-min min))
      finally (setf (btree-min (setq node (btrail-node (first path))))
                    (get-min (btree-left node))))))

(defun fix-right-path (path)
  (when path
    (loop
      with max = (btrail-node (first path)) and x-trail and node
      while (rest path)
      do (pop path)
      do (setq x-trail (first path))
      while (equal (btrail-dir x-trail) *right*)
      do (setf (btree-max (btrail-node x-trail)) (get-max max))
      finally (setf (btree-max (setq node (btrail-node (first path))))
                    (get-max (btree-right node))))))


;;  --> balance/direction routines

(defun rev-dir (dir)
  "reverses the direction left <-> right"
  (if (= dir *right*)
    *left*
    *right*))

(defun all-height-balanced (tree)
  "Return t iff the tree is height balanced
That is, the heights of the left/right branches differ by at most 1."
  (or (null tree)
      (and (height-balanced tree)
           (all-height-balanced (btree-left tree))
           (all-height-balanced (btree-right tree)))))

(defun height-balanced (tree)
  (or (null tree)
      (let ((left (height-btree (btree-left tree)))
            (right (height-btree (btree-right tree))))
        (if (<= (abs (- left right)) 1)
          t
          (progn (print-tree tree)
                 (print-db left right)
                 nil)))))

(defun rev-balance (prev-pivot pivot)
  "reverses the direction left-taller <-> right-taller"
  (if (eq prev-pivot (btree-right pivot))
    *left-taller*
    *right-taller*))

(defun to-balance (prev-pivot pivot)
  (if (eq prev-pivot (btree-right pivot))
    *right-taller*
    *left-taller*))

(defun add-balance (path)
  "Called after adding a node when rebalancing may be required.
Adjusts the balance factors and rotates the tree if necessary.
Stops when the tree is balanced or after a rotation."
  (let* ((balance-point path)
         (old-path path)
         (temp (pop path))
         (pivot (btrail-node temp))
         prev-pivot
         new-balance
         (balance (btree-balance pivot)))
    (loop
      (unless path
        (return t))
      (setf prev-pivot pivot
            old-path path
            temp (pop path)
            pivot (btrail-node temp)
            balance (btree-balance pivot))
      (unless (and path (= balance *balanced*))
        (return t))
      (setf (btree-balance pivot)
            (to-balance prev-pivot pivot)))
    (setf new-balance (if (eq (btree-left pivot) prev-pivot)
                        *left-taller*
                        *right-taller*)
          balance (btree-balance pivot))
    (if (not (= balance new-balance))
      (incf (btree-balance pivot) new-balance)
      (progn (rotate-tree prev-pivot pivot new-balance)
             (setf balance-point
                   old-path)))
    (check-leaf pivot)
    balance-point))

(defun del-balance (path)
  "Called after deleting a node when rebalancing may be required.
Adjusts the balance factors and rotates the tree
if necessary. Continues rebalancing until
1. the tree becomes height balanced
2. rebalancing has reached the root.
3. the b-node has height h+1 and we have rotated the tree."
  (when path
    (let ((balance-point path))
      (loop
        with terminate and temp and z-node and dir
        until (null path)
        do (setq temp (first path)
                 dir (btrail-dir temp)
                 z-node (btrail-node (first path)))
        do (select (btree-balance z-node)
             (dir (setf (btree-balance z-node) *balanced*)
                  (if (rest path)
                    (pop path)
                    (setq terminate t)))
             (*balanced*
              (setf (btree-balance z-node) (rev-dir dir)) ; from (-
              (setq terminate t))
             (t (multiple-value-setq (path z-node terminate)
                  (del-rotate path))
                (check-leaf z-node)))
        until terminate)
      (let ((tree (find-root path)))
        (unless (check-tree tree
                            (min-val tree)
                            (max-val tree))
          (break "not-balanced")))
      balance-point)))

;;--> rotating trees to correct the balance
(defun rotate-tree (prev-pivot pivot new-balance)
  (if (is-leaf pivot)
    pivot
    (let (child)
      (setq child
            (if (= new-balance *right-taller*)
              (btree-right pivot)
              (btree-left pivot)))
      (multiple-value-bind (w-node y-node z-node)
                           (if (= (btree-balance prev-pivot) (- new-balance))
                             (rotate-double pivot child (if (equal (btree-balance child) *left-taller*)
                                                          (btree-left child)
                                                          (btree-right child)))
                             (rotate-single pivot child))
        (when y-node
          (setf (btree-min y-node) (get-min (btree-left y-node))
                (btree-max y-node) (get-max (btree-right y-node))))
        (when z-node
          (setf (btree-min z-node) (get-min (btree-left z-node))
                (btree-max z-node) (get-max (btree-right z-node))))

        (when w-node
          (setf (btree-min w-node) (get-min (btree-left w-node))
                (btree-max w-node) (get-max (btree-right w-node))))
        (values w-node y-node z-node)))))

(defun rotate-single (a-node b-node)
  (let* ((dir (if (eq b-node (btree-left a-node)) *left* *right*))
         (alpha (link (rev-dir dir) a-node))
         (beta (link (rev-dir dir) b-node))
         (gamma (link dir b-node)))
    (swap-key a-node b-node)
    (rotatef a-node b-node)
    (set-link dir b-node gamma)
    (set-link  (rev-dir dir) b-node a-node)
    (set-link dir a-node beta)
    (set-link  (rev-dir dir) a-node alpha)
    (setf (btree-balance a-node) *balanced*)
    (setf (btree-balance b-node) *balanced*)
    (values b-node a-node)))

(defun rotate-double (a-node b-node x-node)
  (let* ((dir (if (eq b-node (btree-left a-node)) *left* *right*))
         (alpha (link  (rev-dir dir) a-node))
         (beta (link  (rev-dir dir) x-node))
         (gamma (link dir x-node))
         (delta (link dir b-node))
         (balance (btree-balance (link  (rev-dir dir) b-node))))
    (swap-key a-node x-node)
    (rotatef a-node x-node)
    (set-link dir b-node delta)
    (set-link  (rev-dir dir) b-node gamma)
    (set-link dir a-node beta)
    (set-link  (rev-dir dir) a-node alpha)
    (set-link  (rev-dir dir) x-node a-node)
    (fix-max-min b-node)
    (fix-max-min a-node)
    (fix-max-min x-node)
    (multiple-value-bind (a-balance b-balance)
                         (select balance
                           (dir (values  (rev-dir dir) *balanced*))
                           (*balanced* (values *balanced* *balanced*))
                           ( (rev-dir dir) (values *balanced* dir)))
      (setf (btree-balance a-node) a-balance
            (btree-balance b-node) b-balance
            (btree-balance x-node) *balanced*)
      (check-leaf a-node)
      (check-leaf b-node)
      (check-leaf x-node)
      (values x-node b-node a-node))))

; addition routines

(defun add-node (key val path order-function)
  "Adds the node with key and val to the tree, starting with the path,
using the order-function.
Adds the node only if the key is not in the tree."
  (if path
    (let (temp dir)
      (setf path
            (find-path key path :order-function order-function :descend t)
            temp (first path)
            dir (btrail-dir temp))
      (unless dir
        (setf path
              (insert-node (make-btree :key key :val val)
                           path order-function)))
      path)
    (root-path (make-btree :key key :val val))))

(defun add-node-right (new-node path order-function)
  "Adds the node with key and val to the tree, starting with the path,
to the right of the first node on the path using the order-function."
  (if path
    (let* ((temp (first path))
           (root (find-root path))
           (old-path (root-path root))
           (key (copy-tree (btree-key new-node)))
           (node (btrail-node temp)))
      (setf (btree-right node) new-node)
      (setf (btrail-dir temp) *right*)
      (push (make-btrail :dir *equal* :node new-node) path)
      (q-adjust-max path)
      (q-adjust-min path)
      (setf path (add-balance path))

      (unless path
        (print 'empty-path)
        (setf path old-path))
      (setq root (find-root path))
      (setq path (find-path key (root-path root) :order-function order-function))
      path)
    (root-path new-node)))

(defun insert-node (new-node path order-function)
  "Inserts the new-node with path pointing to the new-node,
using the order-function."
  (let* ((temp (pop path))
         (dir (btrail-prev temp))
         (key (btree-key new-node))
         node)
    (setf temp (first path)
          node (btrail-node temp)
          dir (funcall order-function key (btree-key node)))
    (cond ((= dir *before*)
           (add-turn new-node node temp path *left*))
          ((and nil (is-leaf node)) ;;; changed
           (swap-key node new-node)
           (add-turn new-node node temp path *left*))
          (t (add-turn new-node node temp path *right*)))
    (q-adjust-max-min path)
    (setf path (add-balance path))
    path))

;; --> deletion routines

(defun del-current-node (path)
  "delete the first node on the path since the left/right link is null."
  (let* (child
         (node (btrail-node (first path)))
         (parent (when  (rest path)
                   (second path)))
         (parent-node (when parent
                        (btrail-node parent))))
    (unless parent-node
      (setq parent (first path))
      (setq parent-node node))
    (if (setq child (or (btree-left node) (btree-right node)))
      (progn
        (if (eq parent-node node)
          (progn
            (copy-info child node :left t :min t
                       :right t :max t :balance t))
          (copy-info child node :left t :min t
                     :right t :max t)))
      (progn
        (if parent-node
          (if (eq node (btree-left parent-node))
            (setf (btree-left parent-node) nil)
            (setf (btree-right parent-node) nil)))
        (pop path)))
    (fix-max-min parent-node)
    path))

(defun del-rotate (path)
  "Tree rotation of the tree rooted at the first node of path"
  (let ((z-node (btrail-node (first path)))
        (dir (btrail-dir (first path)))
        y-node
        terminate
        z-bal)
    (setq y-node (if (= dir *left*)
                   (btree-right z-node)
                   (btree-left z-node)))
    (when (equal (btree-balance y-node) *balanced*)
      (setq terminate t))
    (setq z-bal (btree-balance z-node))
    (multiple-value-bind (new-w new-y new-z)
                         (rotate-tree y-node z-node  (rev-dir dir))
      (fix-path path)
      (if terminate
        (progn
          (setf (btree-balance new-w) (btrail-dir (first path))
                (btree-balance new-y) z-bal)
          (values path new-z terminate))
        (next-del-rotate path new-z new-w terminate)))))

(defun delete-node (path order-function)
  "delete the first node in the path"
  (declare (ignore order-function))
  (let* ((temp (when path (first path)))
         (dir (when temp (btrail-dir temp)))
         (node (when temp (btrail-node temp)))
         (del-balance t))
    (if (null dir)
      (progn
        (pop path)
        path)
      (progn
        (if (or (null (btree-right node)) (null (btree-left node)))
          (setq del-balance (rest path)
                path (del-current-node path))
          (setq path (delete-first-greater path)))
        (when path
          (fix-path path)
          (if (and path del-balance)
            (setq path (del-balance path))
            (when del-balance (pop path))))
        path))))

(defun next-del (path z-node)
  (let ((t-node z-node)
        temp
        (new-path path)
        dir)
    (pop path)
    (when path
      (setq new-path path
            temp (first new-path)
            z-node (btrail-node temp)
            dir (btrail-dir temp))
      (setf (btrail-dir temp)
            (if (eq t-node (btree-right z-node))
              *right*
              *left*)))
    (values path z-node dir)))

(defun next-del-rotate (path z-node w-node terminate)
  (let (temp
        (new-path path))
    (pop path)
    (when path
      (setq temp (first path))
      (setq z-node w-node)
      (setq new-path path)
      (setq temp (first new-path)
            z-node (btrail-node temp)))
    (q-adjust-max-min path)
    (values path z-node (or terminate (null path)))))

;; --> testing routines
(defun gen-trees (n elements &key (max-val 1000))
  "Generate n random trees containing elements nodes
with keys chosen from 0 ... max-val"
  (let (test new-tree)
  (dotimes (i n)
    (setq test nil)
    (dotimes (j elements)
      (pushnew (random max-val) test))
    (setq new-tree (to-btreek test #'compare))
    (unless
      (check-tree new-tree (min-val new-tree) (max-val new-tree))
      (print-db test i)
      (print-tree new-tree :title 'bad-tree)
      (break)))))

(defun tree-test (n m &key (max-val 1000))
  "Create n random trees with m keys."
  (dotimes (len m)
    (print-db (1+ len))
    (gen-trees n (1+ len) :max-val max-val)))

(defun test-del (root key-list)
  "deletes the specified keys from the root and prints
the resulting trees"
  (let (path temp dir)
    (print-tree root :title "original")
    (dolist (key key-list)
      (setf path (find-path key (root-path root))
            temp (first path)
            dir (btrail-dir temp))
      (format t "~&deleting key:  ~s~%" key)
      (when dir
        (setf path (delete-node path #'compare)))
      (print-tree root :title (format nil "deleted key: ~s~%" key))
      (print-path path :title (format nil "path after:~%")))))

(defun del-all-nodes (nodes  &key debug)
  "Delete all the nodes in the tree"
  (del-nodes nodes (algebra::permute nodes) :debug debug))

(defun del-nodes (seq dels &key debug)
  "Delete the nodes in dels from the tree with nodes seq"
  (let ((tree (to-btreek seq  #'compare))
        path)
    (when debug (print tree) (print-tree tree :title "start") (print-db seq))
    (loop for key in dels
          when debug do (print-db key)
          do (setq path (find-path key (root-path tree)
                                   :order-function #'compare)
                   tree (find-root (delete-node path #'compare)))
          when debug do (print tree) (print-tree tree :title (format nil "deleted: ~d" key))
          unless (check-tree tree
                                       (min-val tree)
                                       (max-val tree))
          do (print-tree tree) (print-db seq dels)
          (break))))

(defun del-trees (n elements  &key (max-val 1000) debug)
  "Generate a n random trees with elements integer keys (0 .. (1- max-val))
and delete all the nodes from each tree."
  (let (vals)
  (dotimes (i n)
    (setq vals nil)
    (dotimes (j elements)
      (pushnew (random max-val) vals))
    (del-all-nodes vals :debug debug))))

#|
;; create a btree with nodes in the key list and with value fields = key*key
(defparameter my-tree nil)
(defun square-tree (key-list)
  (let (tree)
    (loop for key in key-list
          do (setq tree
                   (find-root (add-node key (* key key) (root-path tree) #'compare))))
    tree))

(setq my-tree (square-tree '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21)))

(metric-btree my-tree)                     ; nodes=21 height=5 ideal/actual = 88%
                                        ; for remainder see below
(print-tree my-tree)

;; find the path to the node with key 11 and print it
(setq path (find-path 11 (root-path my-tree) :order-function #'compare))
(print-path path)

;; find the node with key 11
(setq node (quick-path 11 my-tree :order-function  #'compare))

;; find the node with key 100 (doesn't exist)
(setq node (quick-path 100 my-tree :order-function  #'compare))

;; Print the keys in order using get-next-node
(loop with path = (root-path my-tree)
      do (setq path (get-next-node path))
      until (null path)
      do (print (btree-key (btrail-node (first path)))))
|#
#|
 R 8   [1 21]
    4 L [1 7]
     2 L [1 3]
      1 L [NIL NIL]
      3 R [NIL NIL]
     6 R [5 7]
      5 L [NIL NIL]
      7 R [NIL NIL]
    16 R [9 21]
     12 L [9 15]
      10 L [9 11]
       9 L [NIL NIL]
       11 R [NIL NIL]
      14 R [13 15]
       13 L [NIL NIL]
       15 R [NIL NIL]
   R 18 R [17 21]
      17 L [NIL NIL]
      20 R [19 21]
       19 L [NIL NIL]
       21 R [NIL NIL]

  Path length 5
11   [NIL NIL]
10 R [9 11]
12 L [9 15]
16 L [9 21]
8 R [1 21] R

(NIL NIL 11 121 NIL NIL 0)

nil
|#